home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / bbs / mfm_111b.zip / SCREEN.PAS < prev    next >
Pascal/Delphi Source File  |  1992-01-07  |  4KB  |  143 lines
  1. Unit Screen;
  2.  
  3. Interface
  4.  
  5. Uses Crt, Dos;
  6.  
  7. Type
  8.   ReDirectToType = (Console,ComPort1,ComPort2,StandardIO);
  9. Var
  10.   ReDirectTo : RedirectToType;
  11.  
  12. Function GetInput : Byte;
  13. Procedure NewTextColor(NewColor : byte);
  14. Procedure NewTextBackground(NewColor : Byte);
  15. Procedure AnsiClearScreen;
  16. Procedure AnsiClearToEOL;
  17. Procedure AnsiGotoXY(X, Y : Byte);
  18.  
  19. Implementation
  20. {========================================================================}
  21. Function GetInput : Byte;
  22.   Var
  23.     Msr : Registers;
  24.     NoInputPending : Boolean;
  25.   Begin
  26.     If ReDirectTo In [Console,StandardIO] Then
  27.     Begin
  28.       Msr.ah := $07;
  29.       MsDos(Msr);
  30.       GetInput := Msr.al;
  31.     End
  32.     Else
  33.     Begin
  34.       NoInputPending := True;
  35.       While NoInputPending Do
  36.       Begin
  37.         Msr.ax := $0300;
  38.         If RedirectTo = ComPort1 Then Msr.dx := 0 Else Msr.dx := 1;
  39.         Intr($14,Msr);
  40.         If (Msr.ax And $0080) <> $0080 Then Halt(255);
  41.         If (Msr.ax And $0100) = $0100 Then NoInputPending := False;
  42.       End;
  43.       Msr.ax := $0200;
  44.       If RedirectTo = ComPort1 Then Msr.dx := 0 Else Msr.dx := 1;
  45.       Intr($14,Msr);
  46.       GetInput := Msr.al;
  47.     End;
  48.   End;
  49. {========================================================================}
  50. Procedure NewTextColor(NewColor : byte);
  51.   Var
  52.     NewColorAnsi : String[6];
  53.     Flash : Boolean;
  54.   Begin
  55.     If ReDirectTo = Console Then
  56.     Begin
  57.       TextColor(NewColor);
  58.     End
  59.     Else
  60.     Begin
  61.       If NewColor > 128 Then
  62.       Begin
  63.         NewColor := NewColor - 128;
  64.         Flash := True;
  65.       End
  66.       Else
  67.       Begin
  68.         Flash := False;
  69.       End;
  70.       Case NewColor of
  71.         0 : NewColorAnsi := '30'; {BLACK}
  72.         1 : NewColorAnsi := '34'; {BLUE}
  73.         2 : NewColorAnsi := '32'; {GREEN}
  74.         3 : NewColorAnsi := '36'; {CYAN}
  75.         4 : NewColorAnsi := '31'; {RED}
  76.         5 : NewColorAnsi := '35'; {MAGENTA}
  77.         6 : NewColorAnsi := '33'; {BROWN}
  78.         7 : NewColorAnsi := '37'; {LIGHTGRAY}
  79.         8 : NewColorAnsi := '1;30'; {BLACK}
  80.         9 : NewColorAnsi := '1;34'; {BLUE}
  81.         10: NewColorAnsi := '1;32'; {GREEN}
  82.         11: NewColorAnsi := '1;36'; {CYAN}
  83.         12: NewColorAnsi := '1;31'; {RED}
  84.         13: NewColorAnsi := '1;35'; {MAGENTA}
  85.         14: NewColorAnsi := '1;33'; {BROWN}
  86.         15: NewColorAnsi := '1;37'; {LIGHTGRAY}
  87.       End;
  88.       If Flash Then NewColorAnsi := '5;'+NewColorAnsi Else NewColorAnsi := '0;'+NewColorAnsi;
  89.       Write(^[+'['+NewColorAnsi+'m');
  90.     End;
  91.   End;
  92. {========================================================================}
  93. Procedure NewTextBackground(NewColor : Byte);
  94.   Var
  95.     NewColorAnsi : String[6];
  96.   Begin
  97.     If ReDirectTo = Console Then
  98.     Begin
  99.       TextBackground(NewColor);
  100.     End
  101.     Else
  102.     Begin
  103.       Case NewColor of
  104.         0 : NewColorAnsi := '40'; {BLACK}
  105.         1 : NewColorAnsi := '44'; {BLUE}
  106.         2 : NewColorAnsi := '42'; {GREEN}
  107.         3 : NewColorAnsi := '46'; {CYAN}
  108.         4 : NewColorAnsi := '41'; {RED}
  109.         5 : NewColorAnsi := '45'; {MAGENTA}
  110.         6 : NewColorAnsi := '43'; {BROWN}
  111.         7 : NewColorAnsi := '47'; {LIGHTGRAY}
  112.       End;
  113.       Write(^[+'['+NewColorAnsi+'m');
  114.     End;
  115.   End;
  116. {========================================================================}
  117. Procedure AnsiClearScreen;
  118.   Begin
  119.     If ReDirectTo = Console Then ClrScr Else Write(^[+'[2J');
  120.   End;
  121. {========================================================================}
  122. Procedure AnsiClearToEOL;
  123.   Begin
  124.     If ReDirectTo = Console Then ClrEol Else Write(^[+'[K');
  125.   End;
  126. {========================================================================}
  127. Procedure AnsiGotoXY(X, Y : Byte);
  128.   Var
  129.     Xpos, Ypos : String[2];
  130.   Begin
  131.     If ReDirectTo = Console Then
  132.     Begin
  133.       GotoXY(Y,X);
  134.     End
  135.     Else
  136.     Begin
  137.       Str(X,Xpos); Str(Y,Ypos);
  138.       Write(^[+'['+Xpos+';'+Ypos+'H');
  139.     End;
  140.   End;
  141. {========================================================================}
  142. End.
  143.